home *** CD-ROM | disk | FTP | other *** search
Text File | 2003-02-09 | 36.5 KB | 1,034 lines |
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- ; ** (c) Copyright 1982 Massachusetts Institute of Technology **
-
- (macsyma-module comm)
-
- (DECLARE-TOP (GENPREFIX C)
- (SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG
- $GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST
- $LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP
- $POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB
- $OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG
- $PFEFORMAT DUMMY-VARIABLE-OPERATORS)
- #-cl (*LEXPR FACTOR)
- (FIXNUM I N LARGL LVRS COUNT TIM (SIGNUM1)))
-
- (PROG1 '(OP and OPR properties)
- (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)
- (PUTPROP (CADR X) (CAR X) 'OPR))
- '((MPLUS &+) (MMINUS &-) (MTIMES &*) (MEXPT &**) (MEXPT &^)
- (MNCTIMES |&.|) (RAT &//) (MQUOTIENT &//) (MNCEXPT &^^)
- (MEQUAL &=) (MGREATERP &>) (MLESSP &<) (MLEQP &<=) (MGEQP &>=)
- (MNOTEQUAL ||) (MAND &AND) (MOR &OR) (MNOT &NOT) (MSETQ |&:|)
- (MDEFINE |&:=|) (MDEFMACRO |&::=|) (MQUOTE |&'|) (MLIST &[)
- (MSET |&::|) (MFACTORIAL &!) (MARROW &->) (MPROGN |&(|)
- (MCOND &IF)))
- (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP))
- '((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT)))
- (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPR))
- #-(or Franz Multics)
- '((|&and| MAND) (|&or| MOR) (|¬| MNOT) (|&if| MCOND))
- #+(or Franz Multics)
- '((|&AND| MAND) (|&OR| MOR) (|&NOT| MNOT) (|&IF| MCOND))))
-
-
- (SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP))
- $DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL
- ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL
- $OPSUBST T IN-P NIL SUBSTP NIL)
-
- (DEFMVAR $VECT_CROSS NIL
- "If TRUE allows DIFF(X~Y,T) to work where ~ is defined in
- SHARE;VECT where VECT_CROSS is set to TRUE.")
-
- #+cl
- (DEFMFUN $SUBSTITUTE (old new &optional (expr nil three-arg?))
- (cond (three-arg? (maxima-substitute old new expr))
- (t
- (LET ((L old) (Z new))
- (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
- ($SUBSTITUTE (CADR L) Z))
- ((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
- ((EQ (CAAR L) 'MEQUAL) (MAXIMA-SUBSTITUTE (CADDR L) (CADR L) Z))
- (T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
- (SETQ Z ($SUBSTITUTE (CAR L) Z)))))))))
- #-cl
- (DEfMFUN $SUBSTITUTE N
- (COND ((= N 2)
- (LET ((L (ARG 1)) (Z (ARG 2)))
- (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
- ($SUBSTITUTE (CADR L) Z))
- ((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
- ((EQ (CAAR L) 'MEQUAL) (MAXIMA-SUBSTITUTE (CADDR L) (CADR L) Z))
- (T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
- (SETQ Z ($SUBSTITUTE (CAR L) Z)))))))
- ((= N 3) (MAXIMA-SUBSTITUTE (ARG 1) (ARG 2) (ARG 3)))
- (T (WNA-ERR '$SUBSTITUTE))))
-
- (DECLARE-TOP (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
-
- (DEFMFUN MAXIMA-SUBSTITUTE (X Y Z) ; The args to SUBSTITUTE are assumed to be simplified.
- (DECLARE (SPECIAL X Y ))
- (LET ((IN-P T) (SUBSTP T))
- (IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1))
- (LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z))))
- (SIMPLIFYA
- (IF (ATOM Y)
- (COND ((EQUAL Y -1)
- (SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z)))
- (T
- #+cl
- (cond ((and (not (symbolp x))
- (functionp x))
- (let ((tem (gensym)))
- (setf (get tem 'operators) 'application-operator)
- (setf (symbol-function tem) x)
- (setq x tem))))
- (LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y)))
- (declare (special OPRX OPRY ))
- (SUBST1 Z))))
- (LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT)
- (= (SIGNUM1 (CADDR Y)) 1))
- (MUL2 -1 (CADDR Y))))
- (TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y)))))
- (declare (special NEGXPTY TIMESP))
- (SUBST2 Z)))
- NIL)))
-
- ;Remainder of page is update from F302 --gsb
-
- ;Used only in COMM2 (AT), and below.
- (DEFVAR DUMMY-VARIABLE-OPERATORS
- '(%PRODUCT %SUM %LAPLACE %INTEGRATE %LIMIT %AT))
-
-
-
- (DEFUN SUBST1 (Z) ; Y is an atom
- (COND ((ATOM Z) (IF (EQUAL Y Z) X Z))
- ((SPECREPP Z) (SUBST1 (SPECDISREP Z)))
- ((EQ (CAAR Z) 'BIGFLOAT) Z)
- ((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z))))
- (DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))))
- ((AT-SUBSTP Z) Z)
- ((AND (EQ Y T) (EQ (CAAR Z) 'MCOND))
- (LIST (cons (CAAR Z) nil) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))
- (CADDDR Z) (SUBST1 (CAR (CDDDDR Z)))))
- (T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z))))
- (IF (AND $OPSUBST
- (OR (EQ OPRY (CAAR Z))
- (AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT))))
- (IF (OR (NUMBERP X)
- (MEMQ X '(T NIL $%E $%PI $%I))
- (AND (NOT (ATOM X))
- (NOT (OR (EQ (CAR X) 'LAMBDA)
- (EQ (CAAR X) 'LAMBDA)))))
- (IF (OR (AND (MEMQ 'array (CDAR Z))
- (OR (AND (MNUMP X) $SUBNUMSIMP)
- (AND (NOT (MNUMP X)) (NOT (ATOM X)))))
- ($SUBVARP X))
- (LET ((SUBSTP 'MQAPPLY))
- (SUBST0 (LIST* '(MQAPPLY) X MARGS) Z))
- (MERROR
- "Attempt to MAXIMA-SUBSTITUTE ~M for ~M in ~M~
- ~%Illegal substitution for operator of expression"
- X Y Z))
- (SUBST0 (CONS (cons OPRX nil) MARGS) Z))
- (SUBST0 (CONS (cons (CAAR Z) nil) MARGS) Z))))))
-
- (DEFUN SUBST2 (Z)
- (LET (NEWEXPT)
- (COND ((ATOM Z) Z)
- ((SPECREPP Z) (SUBST2 (SPECDISREP Z)))
- ((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z)
- ((AT-SUBSTP Z) Z)
- ((ALIKE1 Y Z) X)
- ((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X)
- ((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z))
- (SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1)
- ($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z))))))
- (LIST '(MEXPT) X NEWEXPT))
- ((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE)
- (ALIKE1 (CADR Y) (CADR Z)))
- (LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z))))
- (COND ((NULL TAIL) Z)
- (T (CONS (cons (CAAR Z) nil) (CONS X (CDR TAIL)))))))
- (T (RECUR-APPLY #'SUBST2 Z)))))
-
- (DECLARE-TOP (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
-
- (DEFMFUN SUBST0 (NEW OLD)
- (COND ((ALIKE (CDR NEW) (CDR OLD))
- (COND ((EQ (CAAR NEW) (CAAR OLD)) OLD)
- (T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'array (CDAR OLD))) (CDR OLD))
- NIL))))
- ((MEMQ 'array (CDAR OLD))
- (SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL))
- (T (SIMPLIFYA NEW NIL))))
-
- (DEFUN EXPTHACK (Y Z)
- (PROG (NN* DN* YN YD ZN ZD QD)
- (COND ((AND (MNUMP Y) (MNUMP Z))
- (RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y)))
- ((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL)))
- ((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL)))
- (NUMDEN Y) ; (CSIMP) sets NN* and DN*
- (SETQ YN NN* YD DN*)
- (NUMDEN Z)
- (SETQ ZN NN* ZD DN*)
- (SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1)
- ((PROG2 (NUMDEN (DIV* ZD YD))
- (AND (EQUAL DN* 1) (EQUAL NN* 1)))
- 1)
- ((EQUAL NN* 1) (DIV* 1 DN*))
- ((EQUAL DN* 1) NN*)
- (T (RETURN NIL))))
- (NUMDEN (DIV* ZN YN))
- (IF (EQUAL DN* 1) (RETURN (DIV* NN* QD)))))
-
- (DEFUN SUBST-DIFF-MATCH (L1 L2)
- (DO ((L L1 (CDDR L)) (L2 (copy-top-level L2)) (FAILED NIL NIL))
- ((NULL L) L2)
- (DO ((L2 L2 (CDDR L2)))
- ((NULL (CDR L2)) (SETQ FAILED T))
- (IF (ALIKE1 (CAR L) (CADR L2))
- (IF (AND (FIXNUMP (CADR L)) (FIXNUMP (CADDR L2)))
- (COND ((< (CADR L) (CADDR L2))
- (RETURN (RPLACD (CDR L2)
- (CONS (f- (CADDR L2) (CADR L))
- (CDDDR L2)))))
- ((= (CADR L) (CADDR L2))
- (RETURN (RPLACD L2 (CDDDR L2))))
- (T (RETURN (SETQ FAILED T))))
- (RETURN (SETQ FAILED T)))))
- (IF FAILED (RETURN NIL))))
-
- ;This probably should be a subst or macro.
- (DEFUN AT-SUBSTP (Z)
- (AND ATP (OR (MEMQ (CAAR Z) '(%DERIVATIVE %DEL))
- (MEMQ (CAAR Z) DUMMY-VARIABLE-OPERATORS))))
- (DEFMFUN RECUR-APPLY (FUN E)
- (COND ((EQ (CAAR E) 'BIGFLOAT) E)
- ((SPECREPP E) (FUNCALL FUN (SPECDISREP E)))
- (T (LET ((NEWARGS (MAPCAR FUN (CDR E))))
- (IF (ALIKE NEWARGS (CDR E))
- E
- (SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'array (CDAR E))) NEWARGS)
- NIL))))))
-
- (DEFMFUN $DEPENDS N
- (IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments."))
- (DO ((I 1 (f+ I 2)) (L))
- ((> I N) (I-$DEPENDENCIES (NREVERSE L)))
- (COND (($LISTP (ARG I))
- (DO ((L1 (CDR (ARG I)) (CDR L1))) ((NULL L1))
- (SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (f1+ I))) L))))
- (T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (f1+ I))) L))))))
-
- (DEFUN DEPENDS1 (X Y)
- (NONSYMCHK X '$DEPENDS)
- (CONS (cons X nil) (IF ($LISTP Y) (CDR Y) (cons Y nil))))
-
- (DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM)))
-
- (DEFMFUN I-$DEPENDENCIES (L)
- (DOLIST (Z L)
- (COND ((ATOM Z) (MERROR "Wrong format. Try F(X)."))
- ((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'array (CDAR Z)))
- (MERROR "Improper form for DEPENDS:~%~M" Z))
- (T (LET ((Y (MGET (CAAR Z) 'DEPENDS)))
- (MPUTPROP (CAAR Z)
- (SETQ Y (UNION* (REVERSE (CDR Z)) Y))
- 'DEPENDS)
- (unless (cdr $dependencies)
- (setq $dependencies (copy-list '((mlist simp)))))
- (ADD2LNC (CONS (cons (CAAR Z) nil) Y) $DEPENDENCIES)))))
- (CONS '(MLIST SIMP) L))
-
- (DEFMSPEC $GRADEF (L) (SETQ L (CDR L))
- (LET ((Z (CAR L)) (N 0))
- (COND ((ATOM Z)
- (IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF"))
- (MPUTPROP Z
- (CONS (CONS (CADR L) (MEVAL (CADDR L)))
- (MGET Z '$ATOMGRAD))
- '$ATOMGRAD)
- (I-$DEPENDENCIES (cons (LIST (NCONS Z) (CADR L)) nil))
- (ADD2LNC Z $PROPS)
- Z)
- ((OR (MOPP1 (CAAR Z)) (MEMQ 'array (CDAR Z)))
- (MERROR "Wrong arguments to GRADEF:~%~M" Z))
- ((PROG2 (SETQ N (f- (LENGTH Z) (LENGTH L))) (MINUSP N))
- (WNA-ERR '$GRADEF))
- (T (DO ((ZL (CDR Z) (CDR ZL))) ((NULL ZL))
- (IF (NOT (SYMBOLP (CAR ZL)))
- (MERROR "Parameters to GRADEF must be names:~%~M"
- (CAR ZL))))
- (SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X)))
- (CDR L))
- (MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1))
- (NTHCDR (f- (LENGTH Z) N) Z))))
- (PUTPROP (CAAR Z)
- (SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z)))
- (CONS (CDR Z) L))
- 'GRAD)
- (or (cdr $gradefs) (setq $gradefs (copy-list '((mlist simp)))))
- (ADD2LNC (CONS (cons (CAAR Z) nil) (CDR Z)) $GRADEFS)
- Z))))
-
- (DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N))))
-
- (DEFMFUN $DEL (E) (STOTALDIFF E))
-
- (DEFUN DERIV (E)
- (PROG (EXP Z COUNT)
- (COND ((NULL E) (WNA-ERR '$DIFF))
- ((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E))))
- ((NULL (CDDR E)) (NCONC E '(1))))
- (SETQ EXP (CAR E) Z (SETQ E (copy-top-level E)))
- LOOP (IF (OR (NULL DERIVLIST) (zl-MEMBER (CADR Z) DERIVLIST)) (GO DOIT))
- ; DERIVLIST is set by $EV
- (SETQ Z (CDR Z))
- LOOP2(COND ((CDR Z) (GO LOOP))
- ((NULL (CDR E)) (RETURN EXP))
- (T (GO NOUN)))
- DOIT (COND ((NONVARCHECK (CADR Z) '$DIFF))
- ((NULL (CDDR Z)) (WNA-ERR '$DIFF))
- ((NOT (EQ (ml-typep (CADDR Z)) 'fixnum)) (GO NOUN))
- ((MINUSP (SETQ COUNT (CADDR Z)))
- (MERROR "Improper count to DIFF:~%~M" COUNT)))
- LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2))
- ((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0)))
- (SETQ COUNT (f1- COUNT))
- (GO LOOP1)
- NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E))))))
-
- (DEFUN CHAINRULE (E X)
- (LET (W)
- (COND (ISLINP (IF (AND (NOT (ATOM E))
- (EQ (CAAR E) '%DERIVATIVE)
- (NOT (FREEL (CDR E) X)))
- (DIFF%DERIV (LIST E X 1))
- 0))
- ((ATOMGRAD E X))
- ((NOT (SETQ W (MGET (COND ((ATOM E) E)
- ((MEMQ 'array (CDAR E)) (CAAR E))
- ((ATOM (CADR E)) (CADR E))
- (T (CAAADR E)))
- 'DEPENDS)))
- 0)
- (T (LET (DERIVFLAG)
- (ADDN (MAPCAR
- #'(LAMBDA (U)
- (LET ((Y (SDIFF U X)))
- (IF (EQUAL Y 0)
- 0
- (LIST '(MTIMES)
- (OR (ATOMGRAD E U)
- (LIST '(%DERIVATIVE) E U 1))
- Y))))
- W)
- NIL))))))
-
- (DEFUN ATOMGRAD (E X)
- (LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y))))
-
- (DEFUN DEPENDS (E X)
- (COND ((ALIKE1 E X) T)
- ((MNUMP E) NIL)
- ((ATOM E) (MGET E 'DEPENDS))
- (T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X)))))
-
- (DEFUN DEPENDSL (L X) (DOLIST (U L) (IF (DEPENDS U X) (RETURN T))))
-
- (DEFMFUN SDIFF (E X) ; The args to SDIFF are assumed to be simplified.
- (COND ((ALIKE1 E X) 1)
- ((MNUMP E) 0)
- ((OR (ATOM E) (MEMQ 'array (CDAR E))) (CHAINRULE E X))
- ((EQ (CAAR E) 'MRAT) (RATDX E X))
- ((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T))
- ((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X)))
- ((MEMQ (CAAR E) '(%SUM %PRODUCT)) (DIFFSUMPROD E X))
- ((EQ (CAAR E) '%AT) (DIFF-%AT E X))
- ((NOT (DEPENDS E X)) 0)
- ((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T))
- ((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X))
- ((EQ (CAAR E) 'MNCTIMES)
- (LET (($DOTDISTRIB T))
- (ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T)
- (NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X)))))
- ((AND $VECT_CROSS (EQ (CAAR E) '|$~|))
- (ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X))
- `((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E))))
- ((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X))
- ((MEMQ (CAAR E) '(%LOG %PLOG))
- (SDIFFGRAD (COND ((AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS))
- (CONS (CAR E) (CDADR E)))
- (T E))
- X))
- ((EQ (CAAR E) '%DERIVATIVE)
- (COND ((OR (ATOM (CADR E)) (MEMQ 'array (CDAADR E))) (CHAINRULE E X))
- ((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E))))
- (T (DIFF%DERIV (LIST E X 1)))))
- ((MEMQ (CAAR E) '(%BINOMIAL $BETA))
- (LET ((EFACT ($MAKEFACT E)))
- (MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT))))
- ((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X))
- ((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X))
- ((EQ (CAAR E) '%AT) (DIFF-%AT E X))
- ((MEMQ (CAAR E) '(%REALPART %IMAGPART))
- (LIST (cons (CAAR E) nil) (SDIFF (CADR E) X)))
- (T (SDIFFGRAD E X))))
-
- (DEFUN SDIFFGRAD (E X)
- (LET ((FUN (CAAR E)) GRAD ARGS)
- (COND ((AND (EQ FUN 'MQAPPLY) (OLDGET (CAAADR E) 'GRAD))
- (SDIFFGRAD (CONS (cons (CAAADR E) nil) (APPEND (CDADR E) (CDDR E)))
- X))
- ((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (OLDGET FUN 'GRAD))))
- (IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1))))
- ((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD))))
- (MERROR "Wrong number of arguments for ~:M" FUN))
- (T (SETQ ARGS (SDIFFMAP (CDR E) X))
- (ADDN (MAPCAR
- #'MUL2
- (CDR (SUBSTITUTEL
- (CDR E) (CAR GRAD)
- (DO ((L1 (CDR GRAD) (CDR L1))
- (ARGS ARGS (CDR ARGS)) (L2))
- ((NULL L1) (CONS '(MLIST) (NREVERSE L2)))
- (SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0)
- (T (CAR L1)))
- L2)))))
- ARGS)
- T)))))
-
- (DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E))
-
- (DEFUN SDIFFTIMES (L X)
- (PROG (TERM LEFT OUT)
- LOOP (SETQ TERM (CAR L) L (CDR L))
- (SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT))
- (IF (NULL L) (RETURN OUT))
- (SETQ LEFT (CONS TERM LEFT))
- (GO LOOP)))
-
- (DEFUN DIFFEXPT (E X)
- (IF (MNUMP (CADDR E))
- (MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X))
- (MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X))
- (MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T)
- (SDIFF (CADDR E) X))))))
-
- (DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T)))
-
- (PROG1 '(GRAD properties)
- (LET ((HEADER (PURCOPY '(X))))
- (MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD))
- ; All these GRAD templates have been simplified and then the SIMP flags
- ; (which are unnecessary) have been removed to save core space.
- '((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1))
- (%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X)))
- (MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X))
- ((MFACTORIAL) X)))
- (%SIN ((%COS) X))
- (%COS ((MTIMES) -1 ((%SIN) X)))
- (%TAN ((MEXPT) ((%SEC) X) 2))
- (%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2)))
- (%SEC ((MTIMES) ((%SEC) X) ((%TAN) X)))
- (%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X)))
- (%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))
- (%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2)))
- ((RAT) -1 2))))
- (%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))
- (%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)))
- (%ACSC ((MTIMES) -1 ((MEXPT) X -1)
- ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
- (%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
- (%SINH ((%COSH) X))
- (%COSH ((%SINH) X))
- (%TANH ((MEXPT) ((%SECH) X) 2))
- (%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2)))
- (%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X)))
- (%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X)))
- (%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))
- (%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))
- (%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1))
- (%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1)))
- (%ASECH ((MTIMES) -1 ((MEXPT) X -1)
- ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))))
- (%ACSCH ((MTIMES) -1 ((MEXPT) X -1)
- ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))))
- (MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1)))
- (%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2))
- ((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2)))))
- ; ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1)))
- ($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X))))))
-
- (DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))
- ((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)))
- GRAD)
-
- (DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1)
- ((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X)
- ((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1))))
- GRAD)
-
- (DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1)
- ((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1)))
- GRAD)
-
- (DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1)
- ((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X))
- GRAD))
-
- (DEFMFUN ATVARSCHK (ARGL)
- (DO ((LARGL (LENGTH ARGL) (f1- LARGL)) (LATVRS (LENGTH ATVARS)) (L))
- ((NOT (< LATVRS LARGL)) (NCONC ATVARS L))
- (SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L))))
-
- (DEFMFUN NOTLOREQ (X)
- (OR (ATOM X)
- (NOT (MEMQ (CAAR X) '(MLIST MEQUAL)))
- (AND (EQ (CAAR X) 'MLIST)
- (DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T))))))
-
- (DEFMFUN SUBSTITUTEL (L1 L2 E)
- (DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E)
- (SETQ E (MAXIMA-SUBSTITUTE (CAR L1) (CAR L2) E))))
-
- (DEFMFUN UNION* (A B)
- (DO ((A A (CDR A)) (X B)) ((NULL A) X)
- (IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X)))))
-
- (DEFMFUN INTERSECT* (A B)
- (DO ((A A (CDR A)) (X)) ((NULL A) X)
- (IF (MEMALIKE (CAR A) B) (SETQ X (CONS (CAR A) X)))))
-
- (DEFMFUN NTHELEM (N E) (CAR (NTHCDR (f1- N) E)))
-
- (DEFMFUN DELSIMP (E) (DELQ 'SIMP (copy-top-level E) 1))
-
- (DEFMFUN REMSIMP (E)
- (IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E)))))
-
- (DEFMFUN $TRUNC (E)
- (COND ((ATOM E) E)
- ((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E)))
- ((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E))))
- ((SPECREPP E) ($TRUNC (SPECDISREP E)))
- (T E)))
-
- (DEFMFUN NONVARCHECK (E FN)
- (IF (OR (MNUMP E)
- (MAXIMA-INTEGERP E)
- (AND (NOT (ATOM E)) (NOT (EQ (CAAR E) 'MQAPPLY)) (MOPP1 (CAAR E))))
- (MERROR "Non-variable 2nd argument to ~:M:~%~M" FN E)))
-
- (DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T))
-
- (DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL))
-
- (DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T))
-
- (DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL))
-
- (DEFUN DISP1 (LL LABLIST EQNSP)
- (IF LABLIST (SETQ LABLIST (cons '(MLIST SIMP) nil)))
- (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
- ((NULL LL) (OR LABLIST '$DONE))
- (SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L))
- (IF (AND EQNSP (NOT (MEQUALP ANS)))
- (SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS)))
- (IF LABLIST (NCONC LABLIST (cons (ELABEL ANS) nil)))
- (SETQ TIM (RUNTIME))
- (DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS))
- (MTERPRI)
- (TIMEORG TIM)))
-
- (DEFUN DISP2 (E)
- (COND ((ATOM E) E)
- ((EQ (CAAR E) 'MQAPPLY)
- (CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E)))
- (MAPCAR #'MEVAL (CDDR E)))))
- ((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E)))
- ((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E))))
- ((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E))))
- ((MSPECFUNP (CAAR E)) E)
- (T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E))))))
-
- (DEFMFUN ELABEL (E)
- (IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (f1+ $LINENUM)))
- (MAKELABEL $LINECHAR)
- (IF (NOT $NOLABELS) (SET LINELABLE E))
- LINELABLE)
-
- (DEFMFUN $DISPTERMS (E)
- (COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E))
- ((SPECREPP E) ($DISPTERMS (SPECDISREP E)))
- (T (LET (($DISPFLAG T))
- (MTERPRI)
- (DISPLA (GETOP (MOP E)))
- (DO ((E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
- (REVERSE (CDR E))
- (MARGS E))
- (CDR E))) ((NULL E)) (MTERPRI) (DISPLA (CAR E)) (MTERPRI)))
- (MTERPRI)))
- '$DONE)
-
- (DEFMFUN $DISPFORM N
- (IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL))))
- (MERROR "Incorrect arguments to DISPFORM"))
- (LET ((E (ARG 1)))
- (IF (OR (ATOM E)
- (ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E))))
- (MEMQ 'SIMP (CDAR E)))
- E
- (CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E)))
- (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
- (REVERSE (CDR E))
- (CDR E))))))
-
- ;;; These functions implement the Macsyma functions $op and $operatorp.
- ;;; Dan Stanger
- (defmfun $op (expr) ($part expr 0))
-
- (defmfun $operatorp (expr oplist)
- (if ($listp oplist) ($member ($op expr) oplist) (equal ($op expr) oplist)))
-
- (DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART))
-
- (DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART))
-
- (DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART)))
-
- (DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART)))
-
- (DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ; called only by TRANSLATE
- (LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART)))
-
- (DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN)
- (PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP
- LASTELEM LASTCOUNT)
- #-cl(DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT))
- (SETQ SPECP (OR SUBSTFLAG DISPFLAG))
- (IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST)))
- (IF (NULL ARGLIST) (WNA-ERR '$PART))
- (SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST)))
- (WHEN (NULL (SETQ ARGLIST (CDR ARGLIST)))
- (SETQ $PIECE EXP)
- (RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM))
- (DISPFLAG (BOX EXP DISPFLAG))
- (T EXP))))
- (COND ((NOT INFLAG)
- (COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST)))
- (AND ($MATRIXP EXP)
- (OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST)))))
- (SETQ INFLAG T))
- ((NOT SPECP) (SETQ EXP (NFORMAT EXP)))
- (T (SETQ EXP (NFORMAT-ALL EXP)))))
- ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
- (IF (AND (ATOM EXP) (NULL $PARTSWITCH))
- (MERROR "~:M called on atom: ~:M" FN EXP))
- (IF (AND INFLAG SPECP) (SETQ EXP (copy-all-levels EXP)))
- (SETQ EXP* EXP)
- START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR))
- ((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST)))
- (T (CAR ARGLIST))))
- 0)
- (SETQ ARGLIST (CDR ARGLIST))
- (COND ((MNUMP SUBSTITEM)
- (MERROR "~M is an invalid operator in ~:M"
- SUBSTITEM FN))
- ((AND SPECP ARGLIST)
- (IF (EQ (CAAR EXP) 'MQAPPLY)
- (PROG2 (SETQ EXP (CADR EXP)) (GO START))
- (MERROR "Invalid operator in ~:M" FN)))
- (T (SETQ $PIECE (GETOP (MOP EXP)))
- (RETURN
- (COND (SUBSTFLAG
- (SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM)))
- (COND ((MNUMP SUBSTITEM)
- (MERROR "Invalid operator in ~:M:~%~M"
- FN SUBSTITEM))
- ((NOT (ATOM SUBSTITEM))
- (IF (NOT (EQ (CAAR EXP) 'MQAPPLY))
- (RPLACA (RPLACD EXP (CONS (CAR EXP)
- (CDR EXP)))
- '(MQAPPLY)))
- (RPLACA (CDR EXP) SUBSTITEM)
- (RETURN (RESIMPLIFY EXP*)))
- ((EQ (CAAR EXP) 'MQAPPLY)
- (RPLACD EXP (CDDR EXP))))
- (RPLACA EXP (CONS SUBSTITEM
- (IF (AND (MEMQ 'array (CDAR EXP))
- (NOT (MOPP SUBSTITEM)))
- '(ARRAY))))
- (RESIMPLIFY EXP*))
- (DISPFLAG
- (RPLACD EXP (CDR (BOX (copy-all-levels EXP) DISPFLAG)))
- (RPLACA EXP (IF (EQ DISPFLAG T)
- '(MBOX)
- '(MLABOX)))
- (RESIMPLIFY EXP*))
- (T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A))
- $PIECE))))))
- ((NOT (ATOM ARG)) (GO SEVERAL))
- ((NOT (FIXNUMP ARG))
- (MERROR "Non-integer argument to ~:M:~%~M" FN ARG))
- ((< ARG 0) (GO BAD)))
- (IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP)))
- LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (f1- ARG) EXP (CDR EXP))
- (IF (NULL EXP) (GO ERR)) (GO LOOP))
- ((NULL (SETQ ARGLIST (CDR ARGLIST)))
- (RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
- (RPLACA EXP (MEVAL SUBSTITEM))
- (RESIMPLIFY EXP*))
- (DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
- (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
- (RESIMPLIFY EXP*))
- (INFLAG (SETQ $PIECE (CAR EXP)))
- (T (SETQ $PIECE (SIMPLIFY (CAR EXP))))))))
- (SETQ EXP (CAR EXP))
- A (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP)))
- ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
- (GO START)
- ERR (COND ((EQ $PARTSWITCH 'MAPPLY)
- (MERROR "Improper index to list or matrix"))
- ($PARTSWITCH (RETURN (SETQ $PIECE '$END)))
- (T (MERROR "~:M fell off end." FN)))
- BAD (IMPROPER-ARG-ERR ARG FN)
- SEVERAL
- (IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST))
- (GO BAD))
- (SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'array (CDAR EXP)) '(ARRAY))))
- (IF (EQ (CAAR EXP) 'MQAPPLY)
- (SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP))
- (SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP)))
- (SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP)
- (DOLIST (ARG* ARG1)
- (IF (NOT (FIXNUMP ARG*))
- (MERROR "Non-integer argument to ~:M:~%~M" FN ARG*)))
- (WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST))
- (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))
- (SETQ ARG1 (SORT (copy-top-level ARG1) #'<)))
- (WHEN (EQ (CAAR ARG) '$ALLBUT)
- (SETQ N (LENGTH EXP))
- (DOLIST (I ARG1)
- (IF (OR (< I 1) (> I N))
- (MERROR "Invalid argument to ~:M:~%~M" FN I)))
- (DO ((I N (f1- I)) (ARG2))
- ((= I 0) (SETQ ARG1 ARG2))
- (IF (NOT (zl-MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2))))
- (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))))
- (IF (NULL ARG1) (IF SPECP (GO BAD) (GO END)))
- (IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM))
- SEVLOOP
- (IF SPECP
- (SETQ COUNT (f- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1))
- (SETQ COUNT (CAR ARG1)))
- (IF (< COUNT 1) (GO BAD))
- (IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM))
- (SETQ LASTCOUNT (f1- LASTCOUNT)))
- COUNT(COND ((NULL EXP) (GO ERR))
- ((NOT (= COUNT 1)) (SETQ COUNT (f1- COUNT) EXP (CDR EXP)) (GO COUNT)))
- (SETQ SEVLIST (CONS (CAR EXP) SEVLIST))
- (SETQ ARG1 (CDR ARG1))
- END (COND ((NULL ARG1)
- (SETQ SEVLIST (NREVERSE SEVLIST))
- (SETQ $PIECE (IF (OR INFLAG (NOT SPECP))
- (SIMPLIFY SEVLIST)
- (RESIMPLIFY SEVLIST)))
- (RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (f1- LASTCOUNT) EXP1)
- (MEVAL SUBSTITEM))
- (RESIMPLIFY EXP*))
- (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
- (RESIMPLIFY EXP*))
- (T $PIECE))))
- (SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR))
- (RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP)))
- (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
- (SETQ EXP (CDR EXP)))
- (T (SETQ EXP EXP1)))
- (GO SEVLOOP)))
-
- (DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X))
-
- (DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) x))
-
-
- #-Franz
- (DEFMFUN $LISTP (X) (AND (NOT (ATOM X))
- (not (atom (car x)))
- (EQ (CAAR X) 'MLIST)))
-
- #+Franz ;; -Franz uses a macro definition in MAXMAC.
- (defmfun mlistp (x)
- (and (not (atom x))
- (or (eq (caar x) 'mlist) ($featurep (caar x) '$list))))
-
- #+Franz
- (putd '$listp (getd 'mlistp))
-
- (DEFMFUN $CONS (X E)
- (ATOMCHK (SETQ E (SPECREPCHECK E)) '$CONS T)
- (MCONS-EXP-ARGS E (CONS X (MARGS E))))
-
- (DEFMFUN $ENDCONS (X E)
- (ATOMCHK (SETQ E (SPECREPCHECK E)) '$ENDCONS T)
- (MCONS-EXP-ARGS E (APPEND (MARGS E) (NCONS X))))
-
- (DEFMFUN $REVERSE (E)
- (ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL)
- (MCONS-EXP-ARGS E (REVERSE (MARGS E))))
-
- (DEFMFUN $APPEND N
- (IF (= N 0)
- '((MLIST SIMP))
- (LET ((ARG1 (SPECREPCHECK (ARG 1))) OP ARRP)
- (ATOMCHK ARG1 '$APPEND NIL)
- (SETQ OP (MOP ARG1) ARRP (IF (MEMQ 'array (CDAR ARG1)) T))
- (MCONS-EXP-ARGS
- ARG1
- (APPLY #'APPEND
- (MAPCAR #'(LAMBDA (U)
- (ATOMCHK (SETQ U (SPECREPCHECK U)) '$APPEND NIL)
- (IF (OR (NOT (ALIKE1 OP (MOP U)))
- (NOT (EQ ARRP (IF (MEMQ 'array (CDAR U)) T))))
- (MERROR "Arguments to APPEND are not compatible."))
- (MARGS U))
- (LISTIFY N)))))))
-
- (DEFUN MCONS-EXP-ARGS (E ARGS)
- (IF (EQ (CAAR E) 'MQAPPLY)
- (LIST* (DELSIMP (CAR E)) (CADR E) ARGS)
- (CONS (IF (MLISTP E) (CAR E) (DELSIMP (CAR E))) ARGS)))
-
- (DEFMFUN $MEMBER (X E)
- (ATOMCHK (SETQ E ($TOTALDISREP E)) '$MEMBER T)
- (IF (MEMALIKE ($TOTALDISREP X) (MARGS E)) T))
-
- (DEFMFUN ATOMCHK (E FUN 2NDP)
- (IF (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT))
- (MERROR "~Margument value `~M' to ~:M was not a list"
- (IF 2NDP '|2nd | "") E FUN)))
-
- (DEFMFUN FORMAT1 (E)
- (COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E))))
-
- (DEFMFUN $FIRST (E)
- (ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL)
- (IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty."))
- (CAR (MARGS E)))
-
- ; This macro is used to create functions second thru tenth.
- ; Rather than try to modify mformat for ~:R, use the quoted symbol
- ; Following is Dr. Fateman's clever way to convert a symbol such as second
- ; into $second. Dan Stanger
-
- ;; If s is the symbol foo, (dollarify s) is the symbol $foo
- (eval-when (compile eval load)
- (defun dollarify (s) (intern (concatenate 'string "$" (symbol-name s)))))
-
- (defmacro make-nth (si i)
- (let ((sim (dollarify si)))
- `(DEFMFUN ,sim (E)
- (ATOMCHK (SETQ E (FORMAT1 E)) ',sim NIL)
- (IF (< (LENGTH (MARGS E)) ,i)
- (MERROR "There is no ~A element:~%~M" ',si E))
- (,si (MARGS E)))))
-
- (make-nth SECOND 2)
- (make-nth THIRD 3)
- (make-nth FOURTH 4)
- (make-nth FIFTH 5)
- (make-nth SIXTH 6)
- (make-nth SEVENTH 7)
- (make-nth EIGHTH 8)
- (make-nth NINTH 9)
- (make-nth TENTH 10)
-
- (DEFMFUN $REST N
- (PROG (M FUN FUN1 REVP)
- (IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1)))
- (ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL)
- (COND ((= N 1))
- ((NOT (= N 2)) (WNA-ERR '$REST))
- ((NOT (FIXNUMP (ARG 2)))
- (MERROR "2nd argument to REST must be an integer:~%~M"
- (ARG 2)))
- ((MINUSP (SETQ N (ARG 2))) (SETQ N (f- N) REVP T)))
- (IF (< (LENGTH (MARGS M)) N)
- (IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end.")))
- (SETQ FUN (CAR M))
- (IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M)))
- (SETQ M (CDR M))
- (IF REVP (SETQ M (REVERSE M)))
- (DO ((N N (f1- N))) ((ZEROP N)) (SETQ M (CDR M)))
- (SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN))
- (IF REVP (NREVERSE M) M)))
- (IF (EQ (CAR FUN) 'MQAPPLY)
- (RETURN (CONS (CAR M) (CONS FUN1 (CDR M)))))
- (RETURN M)))
-
- (DEFMFUN $LAST (E)
- (ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL)
- (IF (NULL (CDR E)) (MERROR "Argument to LAST is empty."))
- (CAR (LAST E)))
-
- (DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL)
- (CONS '(MLIST) (MARGS E)))
-
- (DEFMFUN $DELETE N
- (COND ((= N 2) (SETQ N -1))
- ((NOT (= N 3)) (WNA-ERR '$DELETE))
- ((OR (NOT (FIXNUMP (ARG 3))) (MINUSP (SETQ N (ARG 3))))
- (MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3))))
- (LET ((X (ARG 1)) (L (ARG 2)))
- (ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T)
- (SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (copy-top-level (CDR L))))
- (PROG (L1)
- (SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L))
- LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L))
- ((ALIKE1 X (SPECREPCHECK (CADR L1)))
- (SETQ N (f1- N)) (RPLACD L1 (CDDR L1)))
- (T (SETQ L1 (CDR L1))))
- (GO LOOP))))
-
- (DEFMFUN $LENGTH (E)
- (SETQ E (COND (($LISTP E) E)
- ((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E))
- (T ($RATDISREP E))))
- (COND ((SYMBOLP E) (MERROR "LENGTH called on atomic symbol ~:M" E))
- ((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT))
- (IF (AND (NOT $INFLAG) (MNEGP E))
- 1
- (MERROR "LENGTH called on number ~:M" E)))
- ((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E)))
- ((EQ (CAAR E) 'MEXPT)
- (IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2))
- (T (LENGTH (CDR (NFORMAT E))))))
-
- (DEFMFUN $ATOM (X)
- (SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT)))
-
- (DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X))
-
- (DEFMFUN $NUM (E)
- (LET (X)
- (COND ((ATOM E) E)
- ((EQ (CAAR E) 'MRAT) ($RATNUMER E))
- ((EQ (CAAR E) 'RAT) (CADR E))
- ((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X)))
- ((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X))))
- (EQ (CAAR X) 'MQUOTIENT))
- (SIMPLIFY (LIST '(MTIMES) -1 (CADR X))))
- (T E))))
-
- (DEFMFUN $DENOM (E)
- (COND ((ATOM E) 1)
- ((EQ (CAAR E) 'MRAT) ($RATDENOM E))
- ((EQ (CAAR E) 'RAT) (CADDR E))
- ((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT)
- (AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E))))
- (EQ (CAAR E) 'MQUOTIENT)))
- (SIMPLIFY (CADDR E)))
- (T 1)))
-
-
- (DEFMFUN $FIX (E) ($ENTIER E))
-
- (DEFMFUN $ENTIER (E)
- (LET ((E1 (SPECREPCHECK E)))
- (COND ((NUMBERP E1) (FIX E1))
- ((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1)))
- (IF (MINUSP (CADR E1)) (SUB1 E) E))
- (($BFLOATP E1)
- (SETQ E (FPENTIER E1))
- (IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1))))
- (SUB1 E)
- E))
- (T (LIST '($ENTIER) E)))))
-
- (DEFMFUN $FLOAT (E)
- (COND ((NUMBERP E) (FLOAT E))
- ((and (symbolp e) (mget e '$numer)))
- ((OR (ATOM E) (MEMQ 'array (CDAR E))) E)
- ((EQ (CAAR E) 'RAT) (FPCOFRAT E))
- ((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E))
- ((MEMQ (CAAR E) '(MEXPT MNCEXPT))
- (LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E)))
- (T (RECUR-APPLY #'$FLOAT E))))
-
- (DEFMFUN $COEFF N
- (COND ((= N 3) (IF (EQUAL (ARG 3) 0)
- (COEFF (ARG 1) (ARG 2) (ARG 3))
- (COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1)))
- ((= N 2) (COEFF (ARG 1) (ARG 2) 1))
- (T (WNA-ERR '$COEFF))))
-
- (DEFMFUN COEFF (E VAR POW)
- (SIMPLIFY
- (COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0))
- ((ATOM E) (IF (EQUAL POW 0) E 0))
- ((EQ (CAAR E) 'MEXPT)
- (COND ((ALIKE1 (CADR E) VAR)
- (IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1))
- ((EQUAL POW 0) E)
- (T 0)))
- ((OR (EQ (CAAR E) 'MPLUS) (MBAGP E))
- (CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E))
- (MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E))))
- ((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW))
- ((EQUAL POW 0) (IF (FREE E VAR) E 0))
- ((EQ (CAAR E) 'MTIMES)
- (LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW))))
- (IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0)))
- (T 0))))
-
- (DECLARE-TOP (SPECIAL POWERS VAR HIFLG NUM FLAG))
-
- (DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T))
- ; These work best on expanded "simple" expressions.
-
- (DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL))
-
- (DEFUN FINDPOWERS (E HIFLG)
- (LET (POWERS NUM FLAG)
- (FINDPOWERS1 E)
- (COND ((NULL POWERS) (IF (NULL NUM) 0 NUM))
- (T (IF NUM (SETQ POWERS (CONS NUM POWERS)))
- (MAXIMIN POWERS (IF HIFLG '$MAX '$MIN))))))
-
- (DEFUN FINDPOWERS1 (E)
- (COND ((ALIKE1 E VAR) (CHECKPOW 1))
- ((ATOM E))
- ((EQ (CAAR E) 'MPLUS)
- (COND ((NOT (FREEL (CDR E) VAR))
- (DO ((E (CDR E) (CDR E))) ((NULL E))
- (SETQ FLAG NIL) (FINDPOWERS1 (CAR E))
- (IF (NULL FLAG) (CHECKPOW 0))))))
- ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E)))
- ((SPECREPP E) (FINDPOWERS1 (SPECDISREP E)))
- (T (MAPC #'FINDPOWERS1 (CDR E)))))
-
- (DEFUN CHECKPOW (POW)
- (SETQ FLAG T)
- (COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS)))
- ((NULL NUM) (SETQ NUM POW))
- (HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW)))
- ((LESSP POW NUM) (SETQ NUM POW))))
-
- (DECLARE-TOP (UNSPECIAL POWERS VAR HIFLG NUM FLAG))
-
-
- ; Undeclarations for the file:
- (DECLARE-TOP (NOTYPE I N LARGL LVRS COUNT TIM))
-